;;;;  $Id: string.sld 114 2012-04-14 05:06:07Z alan.watson.f@gmail.com $
;;;;
;;;;  Copyright (c) Dorai Sitaram 1999-2010.
;;;;  Copyright (c) Alan Watson 2012.
;;;;
;;;; This program is licensed under version 3 of the GNU LGPL. See
;;;; http://www.gnu.org/licenses/lgpl.html.

(define-library (scheme-indent string)

  (export (rename @ref           ref)
          (rename @ref*           ref*)
          (rename @substring     substring)
          (rename @start         start)
          (rename @end           end)
          (rename @next          next)
          (rename @next*         next*)
          (rename @prev          prev)
          (rename @prev*         prev*)
          (rename @<             <)
          (rename @<=            <=)
          (rename @=             =)
          (rename @>             >)
          (rename @>=            >=)
          (rename @+             +)
          (rename @-             -)
          (rename @index->cursor index->cursor)
          (rename @cursor->index cursor->index)
          (rename @start?        start?)
          (rename @end?          end?)
          (rename @all?          all?)
          (rename @in?           in?)
          (rename @ref?          ref?)
          (rename @find          find)
          (rename @find          find-left)
          (rename @find-right    find-right)
          (rename @skip          skip)
          (rename @skip          skip-left)
          (rename @skip-right    skip-right)
          (rename @trim          trim)
          (rename @trim          trim-left)
          (rename @trim-right    trim-right)
          (rename @trim-both     trim-both)
          (rename @prefix?       prefix?)
          (rename @prefix-ci?    prefix-ci?)
          (rename @split         split))

  (import (except (scheme base)
                  string-ref
                  string-set!
                  substring))
  (import (scheme char))
  (import (scheme case-lambda))
  (import (only (chibi string)
                substring-cursor))
  (import (rename (chibi string)
                  (string-cursor-ref @ref)
                  (string-cursor-start @start)
                  (string-cursor-end @end)
                  (string-cursor-next @next)
                  (string-cursor-prev @prev)
                  (string-cursor=? @=)
                  (string-cursor<? @<)
                  (string-cursor<=? @<=)
                  (string-cursor>? @>)
                  (string-cursor>=? @>=)))

  (begin

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (@ref* s i)
      (if (@end? s i)
        #f
        (@ref s i)))

    (define (@next* s i)
      (if (@end? s i)
        i
        (@next s i)))

    (define (@prev* s i)
      (if (@start? s i)
        i
        (@prev s i)))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (@+ s c i)
      (if (positive? i)
        (let loop ((i i) (c c))
          (if (zero? i)
            c
            (loop (- i 1) (@next s c))))
        (let loop ((i i) (c c))
          (if (zero? i)
            c
            (loop (+ i 1) (@prev s c))))))

    (define (@- s c i)
      (@+ s c (- i)))

    (define (@index->cursor s i)
      (@+ s (@start s) i))

    (define (@cursor->index s i)
      (let loop ((j (@start s)) (k 0))
        (if (@= i j)
          k
          (loop (@next s j) (+ k 1)))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (@start? s i)
      (@= i (@start s)))

    (define (@end? s i)
      (@= i (@end s)))

    (define (@all? s i j)
      (and (@start? s i) (@end? s j)))

    (define (@in? s i)
      (@< i (@end s)))

    (define (@ref? s i c)
      (char=? c (@ref s i)))

    (define (@substring s start end)
      ;; Return the substring of s between the start and end arguments,
      ;; unless these refer to the whole string, in which case return s.
      (cond
       ((@all? s start end)
        s)
       ((@= start end)
        "")
       (else
        (substring-cursor s start end))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define-syntax define-with-optionals
      (syntax-rules ()
        ((_ (name . formals) body ...)
         (define name (lambda-with-optionals formals body ...)))))

    (define-syntax lambda-with-optionals
      (syntax-rules ()
        ((_ (i0 (i1 e1) (i2 e2) (i3 e3)) body ...)
         (let ((p (lambda (i0 i1 i2 i3) body ...)))
           (case-lambda
            ((i0)
             (p i0 e1 e2 e3))
            ((i0 i1)
             (p i0 i1 e2 e3))
            ((i0 i1 i2)
             (p i0 i1 i2 e3))
            ((i0 i1 i2 i3)
             (p i0 i1 i2 i3)))))
        ((_ (i0 i1 (i2 e2) (i3 e3) (i4 e4) (i5 e5)) body ...)
         (let ((p (lambda (i0 i1 i2 i3 i4 i5) body ...)))
           (case-lambda
            ((i0 i1)
             (p i0 i1 e2 e3 e4 e5))
            ((i0 i1 i2)
             (p i0 i1 i2 e3 e4 e5))
            ((i0 i1 i2 i3)
             (p i0 i1 i2 i3 e4 e5))
            ((i0 i1 i2 i3 i4)
             (p i0 i1 i2 i3 i4 e5))
            ((i0 i1 i2 i3 i4 i5)
             (p i0 i1 i2 i3 i4 i5)))))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define (criterion->predicate criterion procedure)
      (cond
       ((procedure? criterion)
        criterion)
       ((char? criterion)
        (lambda (c) (char=? c criterion)))
       (else
        (error "invalid criterion argument." procedure criterion))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define-with-optionals
        (@find s
               (criterion char-whitespace?)
               (start (@start s))
               (end (@end s)))
      (let ((p? (criterion->predicate criterion @find)))
        (let loop ((i start))
          (if (and (@< i end) (not (p? (@ref s i))))
            (loop (@next s i))
            i))))

    (define-with-optionals
        (@find-right s
                     (criterion char-whitespace?)
                     (start (@start s))
                     (end (@end s)))
      (let ((p? (criterion->predicate criterion @find-right)))
        (let loop ((i end))
          (if (and (@> i start) (not (p? (@ref s i))))
            (loop (@prev s i))
            i))))

    (define-with-optionals
        (@skip s
               (criterion char-whitespace?)
               (start (@start s))
               (end (@end s)))
      (let ((p? (criterion->predicate criterion @skip)))
        (let loop ((i start))
          (if (and (@< i end) (p? (@ref s i)))
            (loop (@next s i))
            i))))

    (define-with-optionals
        (@skip-right s
                     (criterion char-whitespace?)
                     (start (@start s))
                     (end (@end s)))
      (let ((p? (criterion->predicate criterion @skip-right)))
        (let loop ((i end))
          (if (and (@> i start) (p? (@ref s (@prev s i))))
            (loop (@prev s i))
            i))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define-with-optionals
        (@trim s
               (criterion char-whitespace?)
               (start (@start s))
               (end (@end s)))
      (let* ((p? (criterion->predicate criterion @trim))
             (i (@skip s p? start end)))
        (@substring s i end)))

    (define-with-optionals
        (@trim-right s
                     (criterion char-whitespace?)
                     (start (@start s))
                     (end (@end s)))
      (let* ((p? (criterion->predicate criterion @trim-right))
             (i (@skip-right s p? start end)))
        (@substring s start i)))

    (define-with-optionals
        (@trim-both s
                    (criterion char-whitespace?)
                    (start (@start s))
                    (end (@end s)))
      (let* ((p? (criterion->predicate criterion @trim-both))
             (i (@skip s p? start end))
             (j (@skip-right s p? i end)))
        (@substring s i j)))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define-with-optionals
        (@split s
                (criterion char-whitespace?)
                (start (@start s))
                (end (@end s)))
      (let ((p? (criterion->predicate criterion @trim)))
        (let loop ((i start) (words '()))
          (let* ((i (@skip s p? i end))
                 (j (@find s p? i end)))
            (if (@= i end)
              (reverse words)
              (loop j (cons (@substring s i j) words)))))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (define-with-optionals
        (@prefix? s0
                     s1
                     (start0 (@start s0))
                     (end0 (@end s0))
                     (start1 (@start s1))
                     (end1 (@end s1)))
      (let loop ((i0 start0) (i1 start1))
        (cond
          ((@= i0 end0) #t)
          ((@= i1 end1) #f)
          ((char=? (@ref s0 i0) (@ref s1 i1))
          (loop (@next s0 i0) (@next s1 i1)))
          (else #f))))

    (define-with-optionals
        (@prefix-ci? s0
                     s1
                     (start0 (@start s0))
                     (end0 (@end s0))
                     (start1 (@start s1))
                     (end1 (@end s1)))
      (let* ((s0 (@substring s0 start0 end0))
             (s1 (@substring s1 start1 end1)))
        (and (<= (string-length s0) (string-length s1))
             (string-ci=? s0
                          (@substring s1
                                      (@start s1)
                                      (@index->cursor s1 (string-length s0)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
